home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / print.d < prev    next >
Text File  |  1987-06-04  |  40KB  |  1,957 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     print.d
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. #define    LINE_LENGTH    72
  14.  
  15. #define    to_be_escaped(c) \
  16.     (standard_readtable->rt.rt_self[(c)&0377].rte_chattrib \
  17.      != cat_constituent || \
  18.      isLower((c)&0377) || (c) == ':')
  19.  
  20. object Kupcase;
  21. object Kdowncase;
  22. object Kcapitalize;
  23.  
  24. object Kstream;
  25. object Kescape;
  26. object Kpretty;
  27. object Kcircle;
  28. object Kbase;
  29. object Kradix;
  30. object Kcase;
  31. object Kgensym;
  32. object Klevel;
  33. object Klength;
  34. object Karray;
  35.  
  36. object Vprint_escape;
  37. object Vprint_pretty;
  38. object Vprint_circle;
  39. object Vprint_base;
  40. object Vprint_radix;
  41. object Vprint_case;
  42. object Vprint_gensym;
  43. object Vprint_level;
  44. object Vprint_length;
  45. object Vprint_array;
  46.  
  47. object siVprint_package;
  48. object siVprint_structure;
  49.  
  50. object *PRINTvs_top;
  51. object *PRINTvs_limit;
  52. object PRINTstream;
  53. bool PRINTescape;
  54. bool PRINTpretty;
  55. bool RPINcircle;
  56. int PRINTbase;
  57. bool PRINTradix;
  58. object PRINTcase;
  59. bool PRINTgensym;
  60. int PRINTlevel;
  61. int PRINTlength;
  62. bool PRINTarray;
  63.  
  64. bool PRINTpackage;
  65. bool PRINTstructure;
  66.  
  67. #define    write_ch    (*write_ch_fun)
  68.  
  69. int (*write_ch_fun)();
  70.  
  71. object siSpretty_print_format;
  72.  
  73. #define    MARK        0400
  74. #define    UNMARK        0401
  75. #define    SET_INDENT    0402
  76. #define    INDENT        0403
  77. #define    INDENT1        0404
  78. #define    INDENT2        0405
  79.  
  80. #define    Q_SIZE        128
  81. #define IS_SIZE        256
  82.  
  83. #define    mod(x)        ((x)%Q_SIZE)
  84.  
  85. static short queue[Q_SIZE];
  86. static short indent_stack[IS_SIZE];
  87.  
  88. static int qh;
  89. static int qt;
  90. static int qc;
  91. static int isp;
  92. static int iisp;
  93.  
  94. writec_queue(c)
  95. int c;
  96. {
  97.     if (qc >= Q_SIZE)
  98.         flush_queue(FALSE);
  99.     if (qc >= Q_SIZE)
  100.         FEerror("Can't pretty-print.", 0);
  101.     queue[qt] = c;
  102.     qt = mod(qt+1);
  103.     qc++;
  104. }
  105.  
  106. flush_queue(force)
  107. {
  108.     int c, i, j, k, l, i0;
  109.  
  110. BEGIN:
  111.     while (qc > 0) {
  112.         c = queue[qh];
  113.         if (c == MARK)
  114.             goto DO_MARK;
  115.         else if (c == UNMARK)
  116.             isp -= 2;
  117.         else if (c == SET_INDENT)
  118.             indent_stack[isp] = file_column(PRINTstream);
  119.         else if (c == INDENT) {
  120.             goto DO_INDENT;
  121.         } else if (c == INDENT1) {
  122.             i = file_column(PRINTstream)-indent_stack[isp];
  123.             if (i < 8 && indent_stack[isp] < LINE_LENGTH/2) {
  124.                 writec_stream(' ', PRINTstream);
  125.                 indent_stack[isp]
  126.                 = file_column(PRINTstream);
  127.             } else {
  128.                 if (indent_stack[isp] < LINE_LENGTH/2) {
  129.                     indent_stack[isp]
  130.                     = indent_stack[isp-1] + 4;
  131.                 }
  132.                 goto DO_INDENT;
  133.             }
  134.         } else if (c == INDENT2) {
  135.             indent_stack[isp] = indent_stack[isp-1] + 2;
  136.             goto PUT_INDENT;
  137.         } else if (c < 0400)
  138.             writec_stream(c, PRINTstream);
  139.         qh = mod(qh+1);
  140.         --qc;
  141.     }
  142.     return;
  143.  
  144. DO_MARK:
  145.     k = LINE_LENGTH - 1 - file_column(PRINTstream);
  146.     for (i = 1, j = 0, l = 1;  l > 0 && i < qc && j < k;  i++) {
  147.         c = queue[mod(qh + i)];
  148.         if (c == MARK)
  149.             l++;
  150.         else if (c == UNMARK)
  151.             --l;
  152.         else if (c == INDENT || c == INDENT1 || c == INDENT2)
  153.             j++;
  154.         else if (c < 0400)
  155.             j++;
  156.     }
  157.     if (l == 0)
  158.         goto FLUSH;
  159.     if (i == qc && !force)
  160.         return;
  161.     qh = mod(qh+1);
  162.     --qc;
  163.     if (++isp >= IS_SIZE-1)
  164.         FEerror("Can't pretty-print.", 0);
  165.     indent_stack[isp++] = file_column(PRINTstream);
  166.     indent_stack[isp] = indent_stack[isp-1];
  167.     goto BEGIN;
  168.  
  169. DO_INDENT:
  170.     if (iisp > isp)
  171.         goto PUT_INDENT;
  172.     k = LINE_LENGTH - 1 - file_column(PRINTstream);
  173.     for (i0 = 0, i = 1, j = 0, l = 1;  i < qc && j < k;  i++) {
  174.         c = queue[mod(qh + i)];
  175.         if (c == MARK)
  176.             l++;
  177.         else if (c == UNMARK) {
  178.             if (--l == 0)
  179.                 goto FLUSH;
  180.         } else if (c == SET_INDENT) {
  181.             if (l == 1)
  182.                 break;
  183.         } else if (c == INDENT) {
  184.             if (l == 1)
  185.                 i0 = i;
  186.             j++;
  187.         } else if (c == INDENT1) {
  188.             if (l == 1)
  189.                 break;
  190.             j++;
  191.         } else if (c == INDENT2) {
  192.             if (l == 1) {
  193.                 i0 = i;
  194.                 break;
  195.             }
  196.             j++;
  197.         } else if (c < 0400)
  198.             j++;
  199.     }
  200.     if (i == qc && !force)
  201.         return;
  202.     if (i0 == 0)
  203.         goto PUT_INDENT;
  204.     i = i0;
  205.     goto FLUSH;
  206.  
  207. PUT_INDENT:
  208.     qh = mod(qh+1);
  209.     --qc;
  210.     writec_stream('\n', PRINTstream);
  211.     for (i = indent_stack[isp];  i > 0;  --i)
  212.         writec_stream(' ', PRINTstream);
  213.     iisp = isp;
  214.     goto BEGIN;
  215.  
  216. FLUSH:
  217.     for (j = 0;  j < i;  j++) {
  218.         c = queue[qh];
  219.         if (c == INDENT || c == INDENT1 || c == INDENT2)
  220.             writec_stream(' ', PRINTstream);
  221.         else if (c < 0400)
  222.             writec_stream(c, PRINTstream);
  223.         qh = mod(qh+1);
  224.         --qc;
  225.     }
  226.     goto BEGIN;
  227. }
  228.  
  229. writec_PRINTstream(c)
  230. int c;
  231. {
  232.     if (c == INDENT || c == INDENT1)
  233.         writec_stream(' ', PRINTstream);
  234.     else if (c < 0400)
  235.         writec_stream(c, PRINTstream);
  236. }
  237.  
  238. write_str(s)
  239. char *s;
  240. {
  241.     while (*s != '\0')
  242.         write_ch(*s++);
  243. }
  244.  
  245. write_decimal(i)
  246. int i;
  247. {
  248.     if (i == 0) {
  249.         write_ch('0');
  250.         return;
  251.     }
  252.     write_decimal1(i);
  253. }
  254.  
  255. write_decimal1(i)
  256. int i;
  257. {
  258.     if (i == 0)
  259.         return;
  260.     write_decimal1(i/10);
  261.     write_ch(i%10 + '0');
  262. }
  263.  
  264. write_addr(x)
  265. object x;
  266. {
  267.     int i, j, k;
  268.  
  269.     i = (int)x;
  270.     for (j = 28;  j >= 0;  j -= 4) {
  271.         k = (i>>j) & 0xf;
  272.         if (k < 10)
  273.             write_ch('0' + k);
  274.         else
  275.             write_ch('a' + k - 10);
  276.     }
  277. }
  278.  
  279. write_base()
  280. {
  281.     if (PRINTbase == 2)
  282.         write_str("#b");
  283.     else if (PRINTbase == 8)
  284.         write_str("#o");
  285.     else if (PRINTbase == 16)
  286.         write_str("#x");
  287.     else if (PRINTbase >= 10) {
  288.         write_ch('#');
  289.         write_ch(PRINTbase/10+'0');
  290.         write_ch(PRINTbase%10+'0');
  291.         write_ch('r');
  292.     } else {
  293.         write_ch('#');
  294.         write_ch(PRINTbase+'0');
  295.         write_ch('r');
  296.     }
  297. }
  298.  
  299. edit_double(n, d, sp, s, ep)
  300. int n;
  301. double d;
  302. char *s;
  303. int *sp;
  304. int *ep;
  305. {
  306.     char *p, buff[24];
  307.     int i;
  308.  
  309. #ifdef IEEEFLOAT
  310.     if ((*(int *)&d & 0x7ff00000) == 0x7ff00000)
  311.         FEerror("Can't print a non-number.",
  312.             0);
  313.     else
  314.         sprintf(buff, "%23.15e", d);
  315.     if (buff[18] != 'e') {
  316.         sprintf(buff, "%22.15e", d);
  317.         *ep = (buff[20]-'0')*10 + (buff[21]-'0');
  318.     } else
  319.         *ep = (buff[20]-'0')*100 + (buff[21]-'0')*10 + (buff[22]-'0');
  320.     *sp = 1;
  321.     if (buff[0] == '-')
  322.         *sp *= -1;
  323. #else
  324.     sprintf(buff, "%22.15e", d);
  325.     /*  "-D.MMMMMMMMMMMMMMMe+EE"  */
  326.     /*   0123456789012345678901   */
  327.     *sp = 1;
  328.     if (buff[0] == '-')
  329.         *sp *= -1;
  330.     *ep = (buff[20]-'0')*10 + (buff[21]-'0');
  331. #endif
  332.  
  333.     if (buff[19] == '-')
  334.         *ep *= -1;
  335.     buff[2] = buff[1];
  336.     p = buff + 2;
  337.     if (n < 16) {
  338.         if (p[n] >= '5') {
  339.             for (i = n - 1;  i >= 0;  --i)
  340.                 if (p[i] == '9')
  341.                     p[i] = '0';
  342.                 else {
  343.                     p[i]++;
  344.                     break;
  345.                 }
  346.             if (i < 0) {
  347.                 *--p = '1';
  348.                 (*ep)++;
  349.             }
  350.         }
  351.         for (i = 0;  i < n;  i++)
  352.             s[i] = p[i];
  353.     } else {
  354.         for (i = 0;  i < 16;  i++)
  355.             s[i] = p[i];
  356.         for (;  i < n;  i++)
  357.             s[i] = '0';
  358.     }
  359.     s[n] = '\0';
  360. }
  361.  
  362. write_double(d, e, shortp)
  363. double d;
  364. int e;
  365. bool shortp;
  366. {
  367.     int sign;
  368.     char buff[20];
  369.     int exp;
  370.     int i;
  371.     int n = 16;
  372.  
  373.     if (shortp)
  374.         n = 7;
  375.     edit_double(n, d, &sign, buff, &exp);
  376.     if (sign < 0)
  377.         write_ch('-');
  378.     if (-3 <= exp && exp < 7) {
  379.         if (exp < 0) {
  380.             write_ch('0');
  381.             write_ch('.');
  382.             exp = (-exp) - 1;
  383.             for (i = 0;  i < exp;  i++)
  384.                 write_ch('0');
  385.             for (;  n > 0;  --n)
  386.                 if (buff[n-1] != '0')
  387.                     break;
  388.             if (exp == 0 && n == 0)
  389.                 n = 1;
  390.             for (i = 0;  i < n;  i++)
  391.                 write_ch(buff[i]);
  392.         } else {
  393.             exp++;
  394.             for (i = 0;  i < exp;  i++)
  395.                 if (i < n)
  396.                     write_ch(buff[i]);
  397.                 else
  398.                     write_ch('0');
  399.             write_ch('.');
  400.             if (i < n)
  401.                 write_ch(buff[i]);
  402.             else
  403.                 write_ch('0');
  404.             i++;
  405.             for (;  n > i;  --n)
  406.                 if (buff[n-1] != '0')
  407.                     break;
  408.             for (;  i < n;  i++)
  409.                 write_ch(buff[i]);
  410.         }
  411.         exp = 0;
  412.     } else {
  413.         write_ch(buff[0]);
  414.         write_ch('.');
  415.         write_ch(buff[1]);
  416.         for (;  n > 2;  --n)
  417.             if (buff[n-1] != '0')
  418.                 break;
  419.         for (i = 2;  i < n;  i++)
  420.             write_ch(buff[i]);
  421.     }
  422.     if (exp == 0 && e == 0)
  423.         return;
  424.     if (e == 0)
  425.         e = 'E';
  426.     write_ch(e);
  427.     if (exp < 0) {
  428.         write_ch('-');
  429.         exp *= -1;
  430.     }
  431.     write_decimal(exp);
  432. }
  433.  
  434. call_structure_print_function(x, level)
  435. object x;
  436. int level;
  437. {
  438.     int i;
  439.     bool eflag;
  440.     bds_ptr old_bds_top;
  441.  
  442.     int (*wf)() = write_ch_fun;
  443.  
  444.     object *vt = PRINTvs_top;
  445.     object *vl = PRINTvs_limit;
  446.     bool e = PRINTescape;
  447.     bool r = PRINTradix;
  448.     int b = PRINTbase;
  449.     bool c = PRINTcircle;
  450.     bool p = PRINTpretty;
  451.     int lv = PRINTlevel;
  452.     int ln = PRINTlength;
  453.     bool g = PRINTgensym;
  454.     bool a = PRINTarray;
  455.  
  456. /*
  457.     short oq[Q_SIZE];
  458. */
  459.     short ois[IS_SIZE];
  460.  
  461.     int oqh;
  462.     int oqt;
  463.     int oqc;
  464.     int oisp;
  465.     int oiisp;
  466.  
  467. ONCE_MORE:
  468.     if (interrupt_flag) {
  469.         interrupt_flag = FALSE;
  470. #ifdef UNIX
  471.         alarm(0);
  472. #endif
  473.         terminal_interrupt(TRUE);
  474.         goto ONCE_MORE;
  475.     }
  476.  
  477.     if (PRINTpretty)
  478.         flush_queue(TRUE);
  479.  
  480.     oqh = qh;
  481.     oqt = qt;
  482.     oqc = qc;
  483.     oisp = isp;
  484.     oiisp = iisp;
  485.  
  486. /*    No need to save the queue, since it is flushed.
  487.     for (i = 0;  i < Q_SIZE;  i++)
  488.         oq[i] = queue[i];
  489. */
  490.     for (i = 0;  i <= isp;  i++)
  491.         ois[i] = indent_stack[i];
  492.  
  493.     vs_push(PRINTstream);
  494.     vs_push(PRINTcase);
  495.  
  496.     vs_push(make_fixnum(level));
  497.  
  498.     old_bds_top = bds_top;
  499.     bds_bind(Vprint_escape, PRINTescape?Ct:Cnil);
  500.     bds_bind(Vprint_radix, PRINTradix?Ct:Cnil);
  501.     bds_bind(Vprint_base, make_fixnum(PRINTbase));
  502.     bds_bind(Vprint_circle, PRINTcircle?Ct:Cnil);
  503.     bds_bind(Vprint_pretty, PRINTpretty?Ct:Cnil);
  504.     bds_bind(Vprint_level, PRINTlevel<0?Cnil:make_fixnum(PRINTlevel));
  505.     bds_bind(Vprint_length, PRINTlength<0?Cnil:make_fixnum(PRINTlength));
  506.     bds_bind(Vprint_gensym, PRINTgensym?Ct:Cnil);
  507.     bds_bind(Vprint_array, PRINTarray?Ct:Cnil);
  508.     bds_bind(Vprint_case, PRINTcase);
  509.  
  510.     frs_push(FRS_PROTECT, Cnil);
  511.     if (nlj_active) {
  512.         eflag = TRUE;
  513.         goto L;
  514.     }
  515.  
  516.     ifuncall3(getf(x->str.str_name->s.s_plist,
  517.                siSstructure_print_function, Cnil),
  518.           x, PRINTstream, vs_head);
  519.     vs_pop;
  520.     eflag = FALSE;
  521.  
  522. L:
  523.     frs_pop();
  524.     bds_unwind(old_bds_top);
  525.  
  526. /*
  527.     for (i = 0;  i < Q_SIZE;  i++)
  528.         queue[i] = oq[i];
  529. */
  530.     for (i = 0;  i <= oisp;  i++)
  531.         indent_stack[i] = ois[i];
  532.  
  533.     iisp = oiisp;
  534.     isp = oisp;
  535.     qc = oqc;
  536.     qt = oqt;
  537.     qh = oqh;
  538.  
  539.     PRINTcase = vs_pop;
  540.     PRINTstream = vs_pop;
  541.     PRINTarray = a;
  542.     PRINTgensym = g;
  543.     PRINTlength = ln;
  544.     PRINTlevel = lv;
  545.     PRINTpretty = p;
  546.     PRINTcircle = c;
  547.     PRINTbase = b;
  548.     PRINTradix = r;
  549.     PRINTescape = e;
  550.     PRINTvs_limit = vl;
  551.     PRINTvs_top = vt;
  552.  
  553.     write_ch_fun = wf;
  554.  
  555.     if (eflag) {
  556.         nlj_active = FALSE;
  557.         unwind(nlj_fr, nlj_tag);
  558.     }
  559. }
  560.  
  561. write_object(x, level)
  562. object x;
  563. int level;
  564. {
  565.     object r, y;
  566.     int i, j, k;
  567.     object *vp;
  568.  
  569.     cs_check(x);
  570.  
  571.     if (x == OBJNULL) {
  572.         write_str("#<OBJNULL>");
  573.         return;
  574.     }
  575.     if (x->d.m == FREE) {
  576.         write_str("#<FREE OBJECT ");
  577.         write_addr(x);
  578.         write_str(">");
  579.         return;
  580.     }
  581.  
  582.     switch (type_of(x)) {
  583.  
  584.     case t_fixnum:
  585.     {
  586.         object *vsp;
  587.  
  588.         if (PRINTradix && PRINTbase != 10)
  589.             write_base();
  590.         i = fix(x);
  591.         if (i == 0) {
  592.             write_ch('0');
  593.             if (PRINTradix && PRINTbase == 10)
  594.                 write_ch('.');
  595.             break;
  596.         }
  597.         if (i < 0) {
  598.             write_ch('-');
  599.             if (i == 0x80000000) {
  600.                 x = alloc_object(t_bignum);
  601.                 x->big.big_car = 0;
  602.                 x->big.big_cdr = NULL;
  603.                 vs_push(x);
  604.                     /*  Saving for GBC,  */
  605.                     /*  since x is a new data.  */
  606.                 x->big.big_cdr
  607.                 = (struct bignum *)
  608.                   alloc_object(t_bignum);
  609.                 x->big.big_cdr->big_car = 1;
  610.                 x->big.big_cdr->big_cdr = NULL;
  611.                 i = PRINTradix;
  612.                 PRINTradix = FALSE;
  613.                 write_object(x, level);
  614.                 PRINTradix = i;
  615.                 vs_pop;
  616.                 if (PRINTradix && PRINTbase == 10)
  617.                     write_ch('.');
  618.                 break;
  619.             }
  620.             i = -i;
  621.         }
  622.         vsp = vs_top;
  623.         for (vsp = vs_top;  i != 0;  i /= PRINTbase)
  624.             vs_push(code_char(digit_weight(i%PRINTbase,
  625.                                PRINTbase)));
  626.         while (vs_top > vsp)
  627.             write_ch(char_code((vs_pop)));
  628.         if (PRINTradix && PRINTbase == 10)
  629.             write_ch('.');
  630.         break;
  631.     }
  632.  
  633.     case t_bignum:
  634.     {
  635.         struct bignum *b;
  636.         object *vsp;
  637.  
  638.         if (PRINTradix && PRINTbase != 10)
  639.             write_base();
  640.         i = big_sign((struct bignum *)x);
  641.         if (i == 0) {
  642.             write_ch('0');
  643.             if (PRINTradix && PRINTbase == 10)
  644.                 write_ch('.');
  645.             break;
  646.         }
  647.         if (i < 0) {
  648.             write_ch('-');
  649.             b = big_minus((struct bignum *)x);
  650.         } else
  651.             b = copy_big((struct bignum *)x);
  652.         vsp = vs_top;
  653.         while (!big_zerop(b))
  654.             vs_check_push(code_char(
  655.                 digit_weight(div_int_big(PRINTbase, b),
  656.                     PRINTbase)));
  657.         while (vs_top > vsp)
  658.             write_ch(char_code((vs_pop)));
  659.         if (PRINTradix && PRINTbase == 10)
  660.             write_ch('.');
  661.         break;
  662.     }
  663.  
  664.     case t_ratio:
  665.         if (PRINTradix) {
  666.             write_base();
  667.             PRINTradix = FALSE;
  668.             write_object(x->rat.rat_num, level);
  669.             write_ch('/');
  670.             write_object(x->rat.rat_den, level);
  671.             PRINTradix = TRUE;
  672.         } else {
  673.             write_object(x->rat.rat_num, level);
  674.             write_ch('/');
  675.             write_object(x->rat.rat_den, level);
  676.         }
  677.         break;
  678.  
  679.     case t_shortfloat:
  680.         r = symbol_value(Vread_default_float_format);
  681.         if (r == Sshort_float)
  682.             write_double((double)sf(x), 0, TRUE);
  683.         else
  684.             write_double((double)sf(x), 'S', TRUE);
  685.         break;
  686.  
  687.     case t_longfloat:
  688.         r = symbol_value(Vread_default_float_format);
  689.         if (r == Ssingle_float ||
  690.             r == Slong_float || r == Sdouble_float)
  691.             write_double(lf(x), 0, FALSE);
  692.         else
  693.             write_double(lf(x), 'F', FALSE);
  694.         break;
  695.  
  696.     case t_complex:
  697.         write_str("#C(");
  698.         write_object(x->cmp.cmp_real, level);
  699.         write_ch(' ');
  700.         write_object(x->cmp.cmp_imag, level);
  701.         write_ch(')');
  702.         break;
  703.  
  704.     case t_character:
  705.         if (!PRINTescape) {
  706.             write_ch(char_code(x));
  707.             break;
  708.         }
  709.         write_str("#\\");
  710.         switch (char_code(x)) {
  711.         case '\r':
  712.             write_str("Return");
  713.             break;
  714.  
  715.         case ' ':
  716.             write_str("Space");
  717.             break;
  718.  
  719.         case '\177':
  720.             write_str("Rubout");
  721.             break;
  722.  
  723.         case '\f':
  724.             write_str("Page");
  725.             break;
  726.  
  727.         case '\t':
  728.             write_str("Tab");
  729.             break;
  730.  
  731.         case '\b':
  732.             write_str("Backspace");
  733.             break;
  734.  
  735.         case '\n':
  736.             write_str("Newline");
  737.             break;
  738.  
  739.         default:
  740.             if (char_code(x) & 0200) {
  741.                 write_ch('\\');
  742.                 i = char_code(x);
  743.                 write_ch(((i>>6)&7) + '0');
  744.                 write_ch(((i>>3)&7) + '0');
  745.                 write_ch(((i>>0)&7) + '0');
  746.             } else if (char_code(x) < 040) {
  747.                 write_ch('^');
  748.                 write_ch(char_code(x) + 0100);
  749.             } else
  750.                 write_ch(char_code(x));
  751.             break;
  752.         }
  753.         break;
  754.  
  755.     case t_symbol:
  756.         if (!PRINTescape) {
  757.             for (i = 0;  i < x->s.s_fillp;  i++) {
  758.                 j = x->s.s_self[i];
  759.                 if (isUpper(j) &&
  760.                     (PRINTcase == Kdowncase ||
  761.                      PRINTcase == Kcapitalize && i!=0))
  762.                     j += 'a' - 'A';
  763.                 write_ch(j);
  764.             }
  765.             break;
  766.         }
  767.         if (x->s.s_hpack == Cnil) {
  768.             if (PRINTcircle) {
  769.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  770.                 if (x == *vp) {
  771.                 if (vp[1] != Cnil) {
  772.                     write_ch('#');
  773.                     write_decimal((vp-PRINTvs_top)/2);
  774.                     write_ch('#');
  775.                     return;
  776.                 } else {
  777.                     write_ch('#');
  778.                     write_decimal((vp-PRINTvs_top)/2);
  779.                     write_ch('=');
  780.                     vp[1] = Ct;
  781.                 }
  782.                 }
  783.             }
  784.             if (PRINTgensym)
  785.             write_str("#:");
  786.         } else if (x->s.s_hpack == keyword_package)
  787.             write_ch(':');
  788.         else if (PRINTpackage||find_symbol(x,current_package())!=x) {
  789.             k = 0;
  790.             for (i = 0;
  791.                  i < x->s.s_hpack->p.p_name->st.st_fillp;
  792.                  i++) {
  793.                 j = x->s.s_hpack->p.p_name
  794.                     ->st.st_self[i];
  795.                 if (to_be_escaped(j))
  796.                     k++;
  797.             }
  798.             if (k > 0)
  799.                 write_ch('|');
  800.             for (i = 0;
  801.                  i < x->s.s_hpack->p.p_name->st.st_fillp;
  802.                  i++) {
  803.                 j = x->s.s_hpack->p.p_name
  804.                     ->st.st_self[i];
  805.                  if (j == '|' || j == '\\')
  806.                     write_ch('\\');
  807.                 if (k == 0 && isUpper(j) &&
  808.                     (PRINTcase == Kdowncase ||
  809.                      PRINTcase == Kcapitalize && i!=0))
  810.                     j += 'a' - 'A';
  811.                 write_ch(j);
  812.             }
  813.             if (k > 0)
  814.                 write_ch('|');
  815.             if (find_symbol(x, x->s.s_hpack) != x)
  816.                 error("can't print symbol");
  817.             if (PRINTpackage || intern_flag == INTERNAL)
  818.                 write_str("::");
  819.             else if (intern_flag == EXTERNAL)
  820.                 write_ch(':');
  821.             else
  822.             FEerror("Pathological symbol --- cannot print.", 0);
  823.         }
  824.         k = 0;
  825.         if (potential_number_p(x, PRINTbase))
  826.             k++;
  827.         for (i = 0;  i < x->s.s_fillp;  i++) {
  828.             j = x->s.s_self[i];
  829.             if (to_be_escaped(j))
  830.                 k++;
  831.         }
  832.         for (i = 0;  i < x->s.s_fillp;  i++)
  833.             if (x->s.s_self[i] != '.')
  834.                 goto NOT_DOT;
  835.         k++;
  836.  
  837.     NOT_DOT:            
  838.         if (k > 0)
  839.             write_ch('|');
  840.         for (i = 0;  i < x->s.s_fillp;  i++) {
  841.             j = x->s.s_self[i];
  842.              if (j == '|' || j == '\\')
  843.                 write_ch('\\');
  844.             if (k == 0 && isUpper(j) &&
  845.                 (PRINTcase == Kdowncase ||
  846.                  PRINTcase == Kcapitalize && i != 0))
  847.                 j += 'a' - 'A';
  848.             write_ch(j);
  849.         }
  850.         if (k > 0)
  851.             write_ch('|');
  852.         break;
  853.  
  854.     case t_array:
  855.     {
  856.         int subscripts[ARANKLIM];
  857.         int n, m;
  858.  
  859.         if (!PRINTarray) {
  860.             write_str("#<array ");
  861.             write_addr(x);
  862.             write_str(">");
  863.             break;
  864.         }
  865.         if (PRINTcircle) {
  866.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  867.                 if (x == *vp) {
  868.                 if (vp[1] != Cnil) {
  869.                     write_ch('#');
  870.                     write_decimal((vp-PRINTvs_top)/2);
  871.                     write_ch('#');
  872.                     return;
  873.                 } else {
  874.                     write_ch('#');
  875.                     write_decimal((vp-PRINTvs_top)/2);
  876.                     write_ch('=');
  877.                     vp[1] = Ct;
  878.                     break;
  879.                 }
  880.                 }
  881.         }
  882.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  883.             write_ch('#');
  884.             break;
  885.         }
  886.         n = x->a.a_rank;
  887.         write_ch('#');
  888.         write_decimal(n);
  889.         write_ch('A');
  890.         if (PRINTlevel >= 0 && level+n >= PRINTlevel)
  891.             n = PRINTlevel - level;
  892.         for (i = 0;  i < n;  i++)
  893.             subscripts[i] = 0;
  894.         m = 0;
  895.         j = 0;
  896.         for (;;) {
  897.             for (i = j;  i < n;  i++) {
  898.                 if (subscripts[i] == 0) {
  899.                     write_ch(MARK);
  900.                     write_ch('(');
  901.                     write_ch(SET_INDENT);
  902.                     if (x->a.a_dims[i] == 0) {
  903.                         write_ch(')');
  904.                         write_ch(UNMARK);
  905.                         j = i-1;
  906.                         k = 0;
  907.                         goto INC;
  908.                     }
  909.                 }
  910.                 if (subscripts[i] > 0)
  911.                     write_ch(INDENT);
  912.                 if (PRINTlength >= 0 &&
  913.                     subscripts[i] >= PRINTlength) {
  914.                     write_str("...)");
  915.                     write_ch(UNMARK);
  916.                     k=x->a.a_dims[i]-subscripts[i];
  917.                     subscripts[i] = 0;
  918.                     for (j = i+1;  j < n;  j++)
  919.                         k *= x->a.a_dims[j];
  920.                     j = i-1;
  921.                     goto INC;
  922.                 }
  923.             }
  924.             if (n == x->a.a_rank) {
  925.                 vs_push(aref(x, m));
  926.                 write_object(vs_head, level+n);
  927.                 vs_pop;
  928.             } else
  929.                 write_ch('#');
  930.             j = n-1;
  931.             k = 1;
  932.  
  933.         INC:
  934.             while (j >= 0) {
  935.                 if (++subscripts[j] < x->a.a_dims[j])
  936.                     break;
  937.                 subscripts[j] = 0;
  938.                 write_ch(')');
  939.                 write_ch(UNMARK);
  940.                 --j;
  941.             }
  942.             if (j < 0)
  943.                 break;
  944.             m += k;
  945.         }
  946.         break;
  947.     }
  948.  
  949.     case t_vector:
  950.         if (!PRINTarray) {
  951.             write_str("#<vector ");
  952.             write_addr(x);
  953.             write_str(">");
  954.             break;
  955.         }
  956.         if (PRINTcircle) {
  957.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  958.                 if (x == *vp) {
  959.                 if (vp[1] != Cnil) {
  960.                     write_ch('#');
  961.                     write_decimal((vp-PRINTvs_top)/2);
  962.                     write_ch('#');
  963.                     return;
  964.                 } else {
  965.                     write_ch('#');
  966.                     write_decimal((vp-PRINTvs_top)/2);
  967.                     write_ch('=');
  968.                     vp[1] = Ct;
  969.                     break;
  970.                 }
  971.                 }
  972.         }
  973.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  974.             write_ch('#');
  975.             break;
  976.         }
  977.         write_ch('#');
  978.         write_ch(MARK);
  979.         write_ch('(');
  980.         write_ch(SET_INDENT);
  981.         if (x->v.v_fillp > 0) {
  982.             if (PRINTlength == 0) {
  983.                 write_str("...)");
  984.                 write_ch(UNMARK);
  985.                 break;
  986.             }
  987.             vs_push(aref(x, 0));
  988.             write_object(vs_head, level+1);
  989.             vs_pop;
  990.             for (i = 1;  i < x->v.v_fillp;  i++) {
  991.                 write_ch(INDENT);
  992.                 if (PRINTlength>=0 && i>=PRINTlength){
  993.                     write_str("...");
  994.                     break;
  995.                 }
  996.                 vs_push(aref(x, i));
  997.                 write_object(vs_head, level+1);
  998.                 vs_pop;
  999.             }
  1000.         }
  1001.         write_ch(')');
  1002.         write_ch(UNMARK);
  1003.         break;
  1004.  
  1005.     case t_string:
  1006.         if (!PRINTescape) {
  1007.             for (i = 0;  i < x->st.st_fillp;  i++)
  1008.                 write_ch(x->st.st_self[i]);
  1009.             break;
  1010.         }
  1011.         write_ch('"');
  1012.         for (i = 0;  i < x->st.st_fillp;  i++) {
  1013.             if (x->st.st_self[i] == '"' ||
  1014.                 x->st.st_self[i] == '\\')
  1015.                 write_ch('\\');
  1016.             write_ch(x->st.st_self[i]);
  1017.         }
  1018.         write_ch('"');
  1019.         break;
  1020.  
  1021.     case t_bitvector:
  1022.         if (!PRINTarray) {
  1023.             write_str("#<bit-vector ");
  1024.             write_addr(x);
  1025.             write_str(">");
  1026.             break;
  1027.         }
  1028.         write_str("#*");
  1029.         for (i = 0;  i < x->bv.bv_fillp;  i++)
  1030.             if (x->bv.bv_self[i/8] & (0200 >> i%8))
  1031.                 write_ch('1');
  1032.             else
  1033.                 write_ch('0');
  1034.         break;
  1035.  
  1036.     case t_cons:
  1037.         if (x->c.c_car == siSsharp_comma) {
  1038.             write_str("#.");
  1039.             write_object(x->c.c_cdr, level);
  1040.             break;
  1041.         }
  1042.         if (PRINTcircle) {
  1043.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  1044.                 if (x == *vp) {
  1045.                 if (vp[1] != Cnil) {
  1046.                     write_ch('#');
  1047.                     write_decimal((vp-PRINTvs_top)/2);
  1048.                     write_ch('#');
  1049.                     return;
  1050.                 } else {
  1051.                     write_ch('#');
  1052.                     write_decimal((vp-PRINTvs_top)/2);
  1053.                     write_ch('=');
  1054.                     vp[1] = Ct;
  1055.                     break;
  1056.                 }
  1057.                 }
  1058.         }
  1059.         if (x->c.c_car == Squote &&
  1060.             type_of(x->c.c_cdr) == t_cons &&
  1061.             x->c.c_cdr->c.c_cdr == Cnil) {
  1062.             write_ch('\'');
  1063.             write_object(x->c.c_cdr->c.c_car, level);
  1064.             break;
  1065.         }
  1066.         if (x->c.c_car == Sfunction &&
  1067.             type_of(x->c.c_cdr) == t_cons &&
  1068.             x->c.c_cdr->c.c_cdr == Cnil) {
  1069.             write_ch('#');
  1070.             write_ch('\'');
  1071.             write_object(x->c.c_cdr->c.c_car, level);
  1072.             break;
  1073.         }
  1074.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  1075.             write_ch('#');
  1076.             break;
  1077.         }
  1078.         write_ch(MARK);
  1079.         write_ch('(');
  1080.         write_ch(SET_INDENT);
  1081.         if (PRINTpretty && x->c.c_car != OBJNULL &&
  1082.             type_of(x->c.c_car) == t_symbol &&
  1083.             (r = getf(x->c.c_car->s.s_plist,
  1084.                       siSpretty_print_format, Cnil)) != Cnil)
  1085.             goto PRETTY_PRINT_FORMAT;
  1086.         for (i = 0;  ;  i++) {
  1087.             if (PRINTlength >= 0 && i >= PRINTlength) {
  1088.                 write_str("...");
  1089.                 break;
  1090.             }
  1091.             y = x->c.c_car;
  1092.             x = x->c.c_cdr;
  1093.             write_object(y, level+1);
  1094.             if (type_of(x) != t_cons) {
  1095.                 if (x != Cnil) {
  1096.                     write_ch(INDENT);
  1097.                     write_str(". ");
  1098.                     write_object(x, level);
  1099.                 }
  1100.                 break;
  1101.             }
  1102.             if (PRINTcircle) {
  1103.               for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
  1104.                 if (x == *vp) {
  1105.                 if (vp[1] != Cnil) {
  1106.                     write_str(" . #");
  1107.                     write_decimal((vp-PRINTvs_top)/2);
  1108.                     write_ch('#');
  1109.                     goto RIGHT_PAREN;
  1110.                 } else {
  1111.                     write_ch(INDENT);
  1112.                     write_str(". ");
  1113.                     write_object(x, level);
  1114.                     goto RIGHT_PAREN;
  1115.                 }
  1116.                 }
  1117.             }
  1118.             if (i == 0 && y != OBJNULL && type_of(y) == t_symbol)
  1119.                 write_ch(INDENT1);
  1120.             else
  1121.                 write_ch(INDENT);
  1122.         }
  1123.  
  1124.     RIGHT_PAREN:
  1125.         write_ch(')');
  1126.         write_ch(UNMARK);
  1127.         break;
  1128.  
  1129.     PRETTY_PRINT_FORMAT:
  1130.         j = fixint(r);
  1131.         for (i = 0;  ;  i++) {
  1132.             if (PRINTlength >= 0 && i >= PRINTlength) {
  1133.                 write_str("...");
  1134.                 break;
  1135.             }
  1136.             y = x->c.c_car;
  1137.             x = x->c.c_cdr;
  1138.             if (i <= j && y == Cnil)
  1139.                 write_str("()");
  1140.             else
  1141.                 write_object(y, level+1);
  1142.             if (type_of(x) != t_cons) {
  1143.                 if (x != Cnil) {
  1144.                     write_ch(INDENT);
  1145.                     write_str(". ");
  1146.                     write_object(x, level);
  1147.                 }
  1148.                 break;
  1149.             }
  1150.             if (i >= j)
  1151.                 write_ch(INDENT2);
  1152.             else if (i == 0)
  1153.                 write_ch(INDENT1);
  1154.             else
  1155.                 write_ch(INDENT);
  1156.         }
  1157.         goto RIGHT_PAREN;
  1158.  
  1159.     case t_package:
  1160.         write_str("#<");
  1161.         write_object(x->p.p_name, level);
  1162.          write_str(" package>");
  1163.         break;
  1164.  
  1165.     case t_hashtable:
  1166.         write_str("#<hash-table ");
  1167.         write_addr(x);
  1168.         write_str(">");
  1169.         break;
  1170.  
  1171.     case t_stream:
  1172.         switch (x->sm.sm_mode) {
  1173.         case smm_input:
  1174.             write_str("#<input stream ");
  1175.             write_object(x->sm.sm_object1, level);
  1176.             write_ch('>');
  1177.             break;
  1178.  
  1179.         case smm_output:
  1180.             write_str("#<output stream ");
  1181.             write_object(x->sm.sm_object1, level);
  1182.             write_ch('>');
  1183.             break;
  1184.  
  1185.         case smm_io:
  1186.             write_str("#<io stream ");
  1187.             write_object(x->sm.sm_object1, level);
  1188.             write_ch('>');
  1189.             break;
  1190.  
  1191.         case smm_probe:
  1192.             write_str("#<probe stream ");
  1193.             write_object(x->sm.sm_object1, level);
  1194.             write_ch('>');
  1195.             break;
  1196.  
  1197.         case smm_synonym:
  1198.             write_str("#<synonym stream to ");
  1199.             write_object(x->sm.sm_object0, level);
  1200.             write_ch('>');
  1201.             break;
  1202.  
  1203.         case smm_broadcast:
  1204.             write_str("#<broadcast stream ");
  1205.             write_addr(x);
  1206.             write_str(">");
  1207.             break;
  1208.  
  1209.         case smm_concatenated:
  1210.             write_str("#<concatenated stream ");
  1211.             write_addr(x);
  1212.             write_str(">");
  1213.             break;
  1214.  
  1215.         case smm_two_way:
  1216.             write_str("#<two-way stream ");
  1217.             write_addr(x);
  1218.             write_str(">");
  1219.             break;
  1220.  
  1221.         case smm_echo:
  1222.             write_str("#<echo stream ");
  1223.             write_addr(x);
  1224.             write_str(">");
  1225.             break;
  1226.  
  1227.         case smm_string_input:
  1228.             write_str("#<string-input stream from \"");
  1229.             y = x->sm.sm_object0;
  1230.             j = y->st.st_fillp;
  1231.             for (i = 0;  i < j && i < 16;  i++)
  1232.                 write_ch(y->st.st_self[i]);
  1233.             if (j > 16)
  1234.                 write_str("...");
  1235.             write_str("\">");
  1236.             break;
  1237.  
  1238.         case smm_string_output:
  1239.             write_str("#<string-output stream ");
  1240.             write_addr(x);
  1241.             write_str(">");
  1242.             break;
  1243.  
  1244.         default:
  1245.             error("illegal stream mode");
  1246.         }
  1247.         break;
  1248.  
  1249.     case t_random:
  1250.         write_str("#$");
  1251.         y = alloc_object(t_fixnum);
  1252.         fix(y) = x->rnd.rnd_value;
  1253.         vs_push(y);
  1254.         write_object(y, level);
  1255.         vs_pop;
  1256.         break;
  1257.  
  1258.     case t_structure:
  1259.         if (PRINTcircle) {
  1260.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  1261.                 if (x == *vp) {
  1262.                 if (vp[1] != Cnil) {
  1263.                     write_ch('#');
  1264.                     write_decimal((vp-PRINTvs_top)/2);
  1265.                     write_ch('#');
  1266.                     return;
  1267.                 } else {
  1268.                     write_ch('#');
  1269.                     write_decimal((vp-PRINTvs_top)/2);
  1270.                     write_ch('=');
  1271.                     vp[1] = Ct;
  1272.                     break;
  1273.                 }
  1274.                 }
  1275.         }
  1276.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  1277.             write_ch('#');
  1278.             break;
  1279.         }
  1280.         if (type_of(x->str.str_name) != t_symbol)
  1281.             FEwrong_type_argument(Ssymbol, x->str.str_name);
  1282.         if (PRINTstructure ||
  1283.             getf(x->str.str_name->s.s_plist,
  1284.              siSstructure_print_function, Cnil) == Cnil) {
  1285.             write_str("#S");
  1286.             x = structure_to_list(x);
  1287.             vs_push(x);
  1288.             write_object(x, level);
  1289.             vs_pop;
  1290.             break;
  1291.         }
  1292.         call_structure_print_function(x, level);
  1293.         break;
  1294.  
  1295.     case t_readtable:
  1296.         write_str("#<readtable ");
  1297.         write_addr(x);
  1298.         write_str(">");
  1299.         break;
  1300.  
  1301.     case t_pathname:
  1302.         if (PRINTescape) {
  1303.             write_ch('#');
  1304.             vs_push(namestring(x));
  1305.             write_object(vs_head, level);
  1306.             vs_pop;
  1307.         } else {
  1308.             write_str("#<pathname ");
  1309.             write_addr(x);
  1310.             write_str(">");
  1311.         }
  1312.         break;
  1313.  
  1314.     case t_cfun:
  1315.         write_str("#<compiled-function ");
  1316.         if (x->cf.cf_name != Cnil)
  1317.             write_object(x->cf.cf_name, level);
  1318.         else
  1319.             write_addr(x);
  1320.         write_str(">");
  1321.         break;
  1322.  
  1323.     case t_cclosure:
  1324.         write_str("#<compiled-closure ");
  1325.         if (x->cc.cc_name != Cnil)
  1326.             write_object(x->cc.cc_name, level);
  1327.         else
  1328.             write_addr(x);
  1329.         write_str(">");
  1330.         break;
  1331.  
  1332.     case t_spice:
  1333.         write_str("#<\100");
  1334.         for (i = 28;  i >= 0;  i -= 4) {
  1335.             j = ((int)x >> i) & 0xf;
  1336.             if (j < 10)
  1337.                 write_ch('0' + j);
  1338.             else
  1339.                 write_ch('A' + (j - 10));
  1340.         }
  1341.         write_ch('>');
  1342.         break;
  1343.  
  1344.     default:
  1345.         error("illegal type --- cannot print");
  1346.     }
  1347. }
  1348.  
  1349. travel_push_object(x)
  1350. object x;
  1351. {
  1352.     enum type t;
  1353.     int i;
  1354.     object *vp;
  1355.  
  1356.     cs_check(x);
  1357.  
  1358. BEGIN:
  1359.     t = type_of(x);
  1360.     if (t != t_array && t != t_vector && t != t_cons &&
  1361.         t != t_structure &&
  1362.         !(t == t_symbol && x->s.s_hpack == Cnil))
  1363.         return;
  1364.     for (vp = PRINTvs_top;  vp < vs_top;  vp += 2)
  1365.         if (x == *vp) {
  1366.             if (vp[1] != Cnil)
  1367.                 return;
  1368.             vp[1] = Ct;
  1369.             return;
  1370.         }
  1371.     vs_check_push(x);
  1372.     vs_check_push(Cnil);
  1373.     if (t == t_array && (enum aelttype)x->a.a_elttype == aet_object)
  1374.         for (i = 0;  i < x->a.a_dim;  i++)
  1375.             travel_push_object(x->a.a_self[i]);
  1376.     else if (t == t_vector && (enum aelttype)x->v.v_elttype == aet_object)
  1377.         for (i = 0;  i < x->v.v_fillp;  i++)
  1378.             travel_push_object(x->v.v_self[i]);
  1379.     else if (t == t_cons) {
  1380.         travel_push_object(x->c.c_car);
  1381.         x = x->c.c_cdr;
  1382.         goto BEGIN;
  1383.     } else if (t == t_structure) {
  1384.         for (i = 0;  i < x->str.str_length;  i++)
  1385.             travel_push_object(x->str.str_self[i]);
  1386.     }
  1387. }
  1388.  
  1389. setupPRINTdefault(x)
  1390. object x;
  1391. {
  1392.     object y;
  1393.     object *vp, *vq;
  1394.  
  1395.     PRINTvs_top = vs_top;
  1396.     PRINTstream = symbol_value(Vstandard_output);
  1397.     if (type_of(PRINTstream) != t_stream) {
  1398.         Vstandard_output->s.s_dbind
  1399.         = symbol_value(Vterminal_io);
  1400.         vs_push(PRINTstream);
  1401.         FEwrong_type_argument(Sstream, PRINTstream);
  1402.     }
  1403.     PRINTescape = symbol_value(Vprint_escape) != Cnil;
  1404.     PRINTpretty = symbol_value(Vprint_pretty) != Cnil;
  1405.     PRINTcircle = symbol_value(Vprint_circle) != Cnil;
  1406.     y = symbol_value(Vprint_base);
  1407.     if (type_of(y) != t_fixnum || fix(y) < 2 || fix(y) > 36) {
  1408.         Vprint_base->s.s_dbind = make_fixnum(10);
  1409.         vs_push(y);
  1410.         FEerror("~S is an illegal PRINT-BASE.", 1, y);
  1411.     } else
  1412.         PRINTbase = fix(y);
  1413.     PRINTradix = symbol_value(Vprint_radix) != Cnil;
  1414.     PRINTcase = symbol_value(Vprint_case);
  1415.     if (PRINTcase != Kupcase && PRINTcase != Kdowncase &&
  1416.         PRINTcase != Kcapitalize) {
  1417.         Vprint_case->s.s_dbind = Kdowncase;
  1418.         vs_push(PRINTcase);
  1419.         FEerror("~S is an illegal PRINT-CASE.", 1, PRINTcase);
  1420.     }
  1421.     PRINTgensym = symbol_value(Vprint_gensym) != Cnil;
  1422.     y = symbol_value(Vprint_level);
  1423.     if (y == Cnil)
  1424.         PRINTlevel = -1;
  1425.     else if (type_of(y) != t_fixnum || fix(y) < 0) {
  1426.         Vprint_level->s.s_dbind = Cnil;
  1427.         vs_push(y);
  1428.         FEerror("~S is an illegal PRINT-LEVEL.", 1, y);
  1429.     } else
  1430.         PRINTlevel = fix(y);
  1431.     y = symbol_value(Vprint_length);
  1432.     if (y == Cnil)
  1433.         PRINTlength = -1;
  1434.     else if (type_of(y) != t_fixnum || fix(y) < 0) {
  1435.         Vprint_length->s.s_dbind = Cnil;
  1436.         vs_push(y);
  1437.         FEerror("~S is an illegal PRINT-LENGTH.", 1, y);
  1438.     } else
  1439.         PRINTlength = fix(y);
  1440.     PRINTarray = symbol_value(Vprint_array) != Cnil;
  1441.     if (PRINTcircle) {
  1442.         travel_push_object(x);
  1443.         for (vp = vq = PRINTvs_top;  vp < vs_top;  vp += 2)
  1444.             if (vp[1] != Cnil) {
  1445.                 vq[0] = vp[0];
  1446.                 vq[1] = Cnil;
  1447.                 vq += 2;
  1448.             }
  1449.         PRINTvs_limit = vs_top = vq;
  1450.     }
  1451.     if (PRINTpretty) {
  1452.         qh = qt = qc = 0;
  1453.         isp = iisp = 0;
  1454.         indent_stack[0] = 0;
  1455.         write_ch_fun = writec_queue;
  1456.     } else
  1457.         write_ch_fun = writec_PRINTstream;
  1458.     PRINTpackage = symbol_value(siVprint_package) != Cnil;
  1459.     PRINTstructure = symbol_value(siVprint_structure) != Cnil;
  1460. }
  1461.  
  1462. cleanupPRINT()
  1463. {
  1464.     vs_top = PRINTvs_top;
  1465.     if (PRINTpretty)
  1466.         flush_queue(TRUE);
  1467. }
  1468.  
  1469. write_object_by_default(x)
  1470. object x;
  1471. {
  1472.     setupPRINTdefault(x);
  1473.     write_object(x, 0);
  1474.     flush_stream(PRINTstream);
  1475.     cleanupPRINT();
  1476. }
  1477.  
  1478. terpri_by_default()
  1479. {
  1480.     PRINTstream = symbol_value(Vstandard_output);
  1481.     if (type_of(PRINTstream) != t_stream)
  1482.         FEwrong_type_argument(Sstream, PRINTstream);
  1483.     writec_stream('\n', PRINTstream);
  1484. }
  1485.  
  1486. bool
  1487. potential_number_p(strng, base)
  1488. object strng;
  1489. int base;
  1490. {
  1491.     int i, l, c, dc;
  1492.     char *s;
  1493.  
  1494.     l = strng->st.st_fillp;
  1495.     if (l == 0)
  1496.         return(FALSE);
  1497.     s = strng->st.st_self;
  1498.     dc = 0;
  1499.     c = s[0];
  1500.     if (digitp(c, base) >= 0)
  1501.         dc++;
  1502.     else if (c != '+' && c != '-' && c != '^' && c != '_')
  1503.         return(FALSE);
  1504.     if (s[l-1] == '+' || s[l-1] == '-')
  1505.         return(FALSE);
  1506.     for (i = 1;  i < l;  i++) {
  1507.         c = s[i];
  1508.         if (digitp(c, base) >= 0) {
  1509.             dc++;
  1510.             continue;
  1511.         }
  1512.         if (c != '+' && c != '-' && c != '/' && c != '.' &&
  1513.             c != '^' && c != '_' &&
  1514.             c != 'e' && c != 'E' &&
  1515.             c != 's' && c != 'S' && c != 'l' && c != 'L')
  1516.             return(FALSE);
  1517.     }
  1518.     if (dc == 0)
  1519.         return(FALSE);
  1520.     return(TRUE);
  1521. }
  1522. @(defun write (x
  1523.            &key ((:stream strm) Cnil)
  1524.             (escape `symbol_value(Vprint_escape)`)
  1525.             (radix `symbol_value(Vprint_radix)`)
  1526.             (base `symbol_value(Vprint_base)`)
  1527.             (circle `symbol_value(Vprint_circle)`)
  1528.             (pretty `symbol_value(Vprint_pretty)`)
  1529.             (level `symbol_value(Vprint_level)`)
  1530.             (length `symbol_value(Vprint_length)`)
  1531.             ((:case cas) `symbol_value(Vprint_case)`)
  1532.             (gensym `symbol_value(Vprint_gensym)`)
  1533.             (array `symbol_value(Vprint_array)`))
  1534.     object *vp, *vq;
  1535. @
  1536.     if (strm == Cnil)
  1537.         strm = symbol_value(Vstandard_output);
  1538.     else if (strm == Ct)
  1539.         strm = symbol_value(Vterminal_io);
  1540.     if (type_of(strm) != t_stream)
  1541.         FEerror("~S is not a stream.", 1, strm);
  1542.     PRINTvs_top = vs_top;
  1543.     PRINTstream = strm;
  1544.     PRINTescape = escape != Cnil;
  1545.     PRINTpretty = pretty != Cnil;
  1546.     PRINTcircle = circle != Cnil;
  1547.     if (type_of(base)!=t_fixnum || fix((base))<2 || fix((base))>36)
  1548.         FEerror("~S is an illegal PRINT-BASE.", 1, base);
  1549.     else
  1550.         PRINTbase = fix((base));
  1551.     PRINTradix = radix != Cnil;
  1552.     PRINTcase = cas;
  1553.     if (PRINTcase != Kupcase && PRINTcase != Kdowncase &&
  1554.         PRINTcase != Kcapitalize)
  1555.         FEerror("~S is an illegal PRINT-CASE.", 1, cas);
  1556.     PRINTgensym = gensym != Cnil;
  1557.     if (level == Cnil)
  1558.         PRINTlevel = -1;
  1559.     else if (type_of(level) != t_fixnum || fix((level)) < 0)
  1560.         FEerror("~S is an illegal PRINT-LEVEL.", 1, level);
  1561.     else
  1562.         PRINTlevel = fix((level));
  1563.     if (length == Cnil)
  1564.         PRINTlength = -1;
  1565.     else if (type_of(length) != t_fixnum || fix((length)) < 0)
  1566.         FEerror("~S is an illegal PRINT-LENGTH.", 1, length);
  1567.     else
  1568.         PRINTlength = fix((length));
  1569.     PRINTarray = array != Cnil;
  1570.     if (PRINTcircle) {
  1571.         travel_push_object(x);
  1572.         for (vp = vq = PRINTvs_top;  vp < vs_top;  vp += 2)
  1573.             if (vp[1] != Cnil) {
  1574.                 vq[0] = vp[0];
  1575.                 vq[1] = Cnil;
  1576.                 vq += 2;
  1577.             }
  1578.         PRINTvs_limit = vs_top = vq;
  1579.     }
  1580.     if (PRINTpretty) {
  1581.         qh = qt = qc = 0;
  1582.         isp = iisp = 0;
  1583.         indent_stack[0] = 0;
  1584.         write_ch_fun = writec_queue;
  1585.     } else
  1586.         write_ch_fun = writec_PRINTstream;
  1587.     PRINTpackage = symbol_value(siVprint_package) != Cnil;
  1588.     PRINTstructure = symbol_value(siVprint_structure) != Cnil;
  1589.     write_object(x, 0);
  1590.     cleanupPRINT();
  1591.     flush_stream(PRINTstream);
  1592.     @(return x)
  1593. @)
  1594.  
  1595. @(defun prin1 (obj &optional strm)
  1596. @
  1597.     prin1(obj, strm);
  1598.     @(return obj)
  1599. @)
  1600.  
  1601. @(defun print (obj &optional strm)
  1602. @
  1603.     print(obj, strm);
  1604.     @(return obj)
  1605. @)
  1606.  
  1607. @(defun pprint (obj &optional strm)
  1608. @
  1609.     if (strm == Cnil)
  1610.         strm = symbol_value(Vstandard_output);
  1611.     else if (strm == Ct)
  1612.         strm = symbol_value(Vterminal_io);
  1613.     check_type_stream(&strm);
  1614.     writec_stream('\n', strm);
  1615.     setupPRINTdefault(obj);
  1616.     PRINTstream = strm;
  1617.     PRINTescape = TRUE;
  1618.     PRINTpretty = TRUE;
  1619.     qh = qt = qc = 0;
  1620.     isp = iisp = 0;
  1621.     indent_stack[0] = 0;
  1622.     write_ch_fun = writec_queue;
  1623.     write_object(obj, 0);
  1624.     cleanupPRINT();
  1625.     flush_stream(strm);
  1626.     @(return)
  1627. @)
  1628.  
  1629. @(defun princ (obj &optional strm)
  1630. @
  1631.     princ(obj, strm);
  1632.     @(return obj)
  1633. @)
  1634.  
  1635. @(defun write_char (c &optional strm)
  1636. @
  1637.     if (strm == Cnil)
  1638.         strm = symbol_value(Vstandard_output);
  1639.     else if (strm == Ct)
  1640.         strm = symbol_value(Vterminal_io);
  1641.     check_type_character(&c);
  1642.     check_type_stream(&strm);
  1643.     writec_stream(char_code(c), strm);
  1644. /*
  1645.     flush_stream(strm);
  1646. */
  1647.     @(return c)
  1648. @)
  1649.  
  1650. @(defun write_string (strng &o strm &k start end)
  1651.     int s, e, i;
  1652. @
  1653.     get_string_start_end(strng, start, end, &s, &e);
  1654.     if (strm == Cnil)
  1655.         strm = symbol_value(Vstandard_output);
  1656.     else if (strm == Ct)
  1657.         strm = symbol_value(Vterminal_io);
  1658.     check_type_string(&strng);
  1659.     check_type_stream(&strm);
  1660.     for (i = s;  i < e;  i++)
  1661.         writec_stream(strng->st.st_self[i], strm);
  1662.     flush_stream(strm);
  1663.     @(return strng)
  1664. @)
  1665.  
  1666. @(defun write_line (strng &o strm &k start end)
  1667.     int s, e, i;
  1668. @
  1669.     get_string_start_end(strng, start, end, &s, &e);
  1670.     if (strm == Cnil)
  1671.         strm = symbol_value(Vstandard_output);
  1672.     else if (strm == Ct)
  1673.         strm = symbol_value(Vterminal_io);
  1674.     check_type_string(&strng);
  1675.     check_type_stream(&strm);
  1676.     for (i = s;  i < e;  i++)
  1677.         writec_stream(strng->st.st_self[i], strm);
  1678.     writec_stream('\n', strm);
  1679.     flush_stream(strm);
  1680.     @(return strng)
  1681. @)
  1682.  
  1683. @(defun terpri (&optional strm)
  1684. @
  1685.     terpri(strm);
  1686.     @(return Cnil)
  1687. @)
  1688.  
  1689. @(defun fresh_line (&optional strm)
  1690. @
  1691.     if (strm == Cnil)
  1692.         strm = symbol_value(Vstandard_output);
  1693.     else if (strm == Ct)
  1694.         strm = symbol_value(Vterminal_io);
  1695.     check_type_stream(&strm);
  1696.     if (file_column(strm) == 0)
  1697.         @(return Cnil)
  1698.     writec_stream('\n', strm);
  1699.     flush_stream(strm);
  1700.     @(return Ct)
  1701. @)
  1702.  
  1703. @(defun finish_output (&o strm)
  1704. @
  1705.     if (strm == Cnil)
  1706.         strm = symbol_value(Vstandard_output);
  1707.     else if (strm == Ct)
  1708.         strm = symbol_value(Vterminal_io);
  1709.     check_type_stream(&strm);
  1710.     flush_stream(strm);
  1711.     @(return Cnil)
  1712. @)
  1713.  
  1714. @(defun force_output (&o strm)
  1715. @
  1716.     if (strm == Cnil)
  1717.         strm = symbol_value(Vstandard_output);
  1718.     else if (strm == Ct)
  1719.         strm = symbol_value(Vterminal_io);
  1720.     check_type_stream(&strm);
  1721.     flush_stream(strm);
  1722.     @(return Cnil)
  1723. @)
  1724.  
  1725. @(defun clear_output (&o strm)
  1726. @
  1727.     if (strm == Cnil)
  1728.         strm = symbol_value(Vstandard_output);
  1729.     else if (strm == Ct)
  1730.         strm = symbol_value(Vterminal_io);
  1731.     check_type_stream(&strm);
  1732.     @(return Cnil)
  1733. @)
  1734.  
  1735. @(defun write_byte (integer binary_output_stream)
  1736. @
  1737.     if (type_of(integer) != t_fixnum)
  1738.         FEerror("~S is not a byte.", 1, integer);
  1739.     check_type_stream(&binary_output_stream);
  1740.     writec_stream(fix(integer), binary_output_stream);
  1741.     @(return integer)
  1742. @)
  1743.  
  1744. init_print()
  1745. {
  1746.     Kupcase = make_keyword("UPCASE");
  1747.     Kdowncase = make_keyword("DOWNCASE");
  1748.     Kcapitalize = make_keyword("CAPITALIZE");
  1749.  
  1750.     Kstream = make_keyword("STREAM");
  1751.     Kescape = make_keyword("ESCAPE");
  1752.     Kpretty = make_keyword("PRETTY");
  1753.     Kcircle = make_keyword("CIRCLE");
  1754.     Kbase = make_keyword("BASE");
  1755.     Kradix = make_keyword("RADIX");
  1756.     Kcase = make_keyword("CASE");
  1757.     Kgensym = make_keyword("GENSYM");
  1758.     Klevel = make_keyword("LEVEL");
  1759.     Klength = make_keyword("LENGTH");
  1760.     Karray = make_keyword("ARRAY");
  1761.  
  1762.     Vprint_escape = make_special("*PRINT-ESCAPE*", Ct);
  1763.     Vprint_pretty = make_special("*PRINT-PRETTY*", Ct);
  1764.     Vprint_circle = make_special("*PRINT-CIRCLE*", Cnil);
  1765.     Vprint_base = make_special("*PRINT-BASE*", make_fixnum(10));
  1766.     Vprint_radix = make_special("*PRINT-RADIX*", Cnil);
  1767.     Vprint_case = make_special("*PRINT-CASE*", Kupcase);
  1768.     Vprint_gensym = make_special("*PRINT-GENSYM*", Ct);
  1769.     Vprint_level = make_special("*PRINT-LEVEL*", Cnil);
  1770.     Vprint_length = make_special("*PRINT-LENGTH*", Cnil);
  1771.     Vprint_array = make_special("*PRINT-ARRAY*", Ct);
  1772.  
  1773.     siVprint_package = make_si_special("*PRINT-PACKAGE*", Cnil);
  1774.     siVprint_structure = make_si_special("*PRINT-STRUCTURE*", Cnil);
  1775.  
  1776.     siSpretty_print_format
  1777.     = make_si_ordinary("PRETTY-PRINT-FORMAT");
  1778.     enter_mark_origin(&siSpretty_print_format);
  1779.  
  1780.     PRINTstream = Cnil;
  1781.     enter_mark_origin(&PRINTstream);
  1782.     PRINTescape = TRUE;
  1783.     PRINTpretty = FALSE;
  1784.     PRINTcircle = FALSE;
  1785.     PRINTbase = 10;
  1786.     PRINTradix = FALSE;
  1787.     PRINTcase = Kupcase;
  1788.     enter_mark_origin(&PRINTcase);
  1789.     PRINTgensym = TRUE;
  1790.     PRINTlevel = -1;
  1791.     PRINTlength = -1;
  1792.     PRINTarray = FALSE;
  1793.  
  1794.     write_ch_fun = writec_PRINTstream;
  1795. }
  1796.  
  1797. object
  1798. princ(obj, strm)
  1799. object obj, strm;
  1800. {
  1801.     if (strm == Cnil)
  1802.         strm = symbol_value(Vstandard_output);
  1803.     else if (strm == Ct)
  1804.         strm = symbol_value(Vterminal_io);
  1805.     if (type_of(strm) != t_stream)
  1806.         FEerror("~S is not a stream.", 1, strm);
  1807.     if (obj == OBJNULL)
  1808.         goto SIMPLE_CASE;
  1809.     switch (type_of(obj)) {
  1810.     case t_symbol:
  1811.         PRINTcase = symbol_value(Vprint_case);
  1812.         PRINTpackage = symbol_value(siVprint_package) != Cnil;
  1813.  
  1814.     SIMPLE_CASE:
  1815.     case t_string:
  1816.     case t_character:
  1817.         PRINTstream = strm;
  1818.         PRINTescape = FALSE;
  1819.         write_ch_fun = writec_PRINTstream;
  1820.         write_object(obj, 0);
  1821.         break;
  1822.  
  1823.     default:
  1824.         setupPRINTdefault(obj);
  1825.         PRINTstream = strm;
  1826.         PRINTescape = FALSE;
  1827.         write_object(obj, 0);
  1828.         cleanupPRINT();
  1829.         break;
  1830.     }
  1831.     return(obj);
  1832. }
  1833.  
  1834. object
  1835. prin1(obj, strm)
  1836. object obj, strm;
  1837. {
  1838.     if (strm == Cnil)
  1839.         strm = symbol_value(Vstandard_output);
  1840.     else if (strm == Ct)
  1841.         strm = symbol_value(Vterminal_io);
  1842.     if (type_of(strm) != t_stream)
  1843.         FEerror("~S is not a stream.", 1, strm);
  1844.     if (obj == OBJNULL)
  1845.         goto SIMPLE_CASE;
  1846.     switch (type_of(obj)) {
  1847.     SIMPLE_CASE:
  1848.     case t_string:
  1849.     case t_character:
  1850.         PRINTstream = strm;
  1851.         PRINTescape = TRUE;
  1852.         write_ch_fun = writec_PRINTstream;
  1853.         write_object(obj, 0);
  1854.         break;
  1855.  
  1856.     default:
  1857.         setupPRINTdefault(obj);
  1858.         PRINTstream = strm;
  1859.         PRINTescape = TRUE;
  1860.         write_object(obj, 0);
  1861.         cleanupPRINT();
  1862.         break;
  1863.     }
  1864.     flush_stream(strm);
  1865.     return(obj);
  1866. }
  1867.  
  1868. object
  1869. print(obj, strm)
  1870. object obj, strm;
  1871. {
  1872.     terpri(strm);
  1873.     prin1(obj, strm);
  1874. }
  1875.  
  1876. object
  1877. terpri(strm)
  1878. object strm;
  1879. {
  1880.     if (strm == Cnil)
  1881.         strm = symbol_value(Vstandard_output);
  1882.     else if (strm == Ct)
  1883.         strm = symbol_value(Vterminal_io);
  1884.     if (type_of(strm) != t_stream)
  1885.         FEerror("~S is not a stream.", 1, strm);
  1886.     writec_stream('\n', strm);
  1887.     flush_stream(strm);
  1888.     return(Cnil);
  1889. }
  1890.  
  1891. write_string(strng, strm)
  1892. object strng, strm;
  1893. {
  1894.     int i;
  1895.  
  1896.     if (strm == Cnil)
  1897.         strm = symbol_value(Vstandard_output);
  1898.     else if (strm == Ct)
  1899.         strm = symbol_value(Vterminal_io);
  1900.     check_type_string(&strng);
  1901.     check_type_stream(&strm);
  1902.     for (i = 0;  i < strng->st.st_fillp;  i++)
  1903.         writec_stream(strng->st.st_self[i], strm);
  1904.     flush_stream(strm);
  1905. }
  1906.  
  1907. /*
  1908.     THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION
  1909. */
  1910. princ_str(s, sym)
  1911. char *s;
  1912. object sym;
  1913. {
  1914.     sym = symbol_value(sym);
  1915.     if (sym == Cnil)
  1916.         sym = symbol_value(Vstandard_output);
  1917.     else if (sym == Ct)
  1918.         sym = symbol_value(Vterminal_io);
  1919.     check_type_stream(&sym);
  1920.     writestr_stream(s, sym);
  1921. }
  1922.  
  1923. princ_char(c, sym)
  1924. int c;
  1925. object sym;
  1926. {
  1927.     sym = symbol_value(sym);
  1928.     if (sym == Cnil)
  1929.         sym = symbol_value(Vstandard_output);
  1930.     else if (sym == Ct)
  1931.         sym = symbol_value(Vterminal_io);
  1932.     check_type_stream(&sym);
  1933.     writec_stream(c, sym);
  1934.     if (c == '\n')
  1935.         flush_stream(sym);
  1936. }
  1937.  
  1938. init_print_function()
  1939. {
  1940.     make_function("WRITE", Lwrite);
  1941.     make_function("PRIN1", Lprin1);
  1942.     make_function("PRINT", Lprint);
  1943.     make_function("PPRINT", Lpprint);
  1944.     make_function("PRINC", Lprinc);
  1945.  
  1946.     make_function("WRITE-CHAR", Lwrite_char);
  1947.     make_function("WRITE-STRING", Lwrite_string);
  1948.     make_function("WRITE-LINE", Lwrite_line);
  1949.     make_function("TERPRI", Lterpri);
  1950.     make_function("FRESH-LINE", Lfresh_line);
  1951.     make_function("FINISH-OUTPUT", Lfinish_output);
  1952.     make_function("FORCE-OUTPUT", Lforce_output);
  1953.     make_function("CLEAR-OUTPUT", Lclear_output);
  1954.  
  1955.     make_function("WRITE-BYTE", Lwrite_byte);
  1956. }
  1957.